home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…ch: Other People's Memory / ADC Developer CD (1993-03) (''Other People's Memory'')_iso / Dev.CD Mar 93.iso / Development Platforms / LISP Related / LISP Goodies / menu enhancements / marking-menu.lisp < prev    next >
Encoding:
Text File  |  1992-09-02  |  59.7 KB  |  1,489 lines  |  [TEXT/CCL2]
  1. (in-package menus)
  2.  
  3. ;;marking-menu.lisp
  4. ;;
  5. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  6. ;; marking-menu.lisp
  7. ;;
  8. ;; Copyright © 1992 University of Toronto, Department of Computer Science
  9. ;; All Rights Reserved
  10. ;;
  11. ;; author: Mark A. Tapia
  12. ;;
  13. ;;  Methods to support a new mixin class of menus for views: marking-menus.
  14. ;;
  15. ;; Marking menus support hierarchical menus. Each menu item in a
  16. ;; marking menu must be a menu-item, a window-menu-item, or a 
  17. ;; marking-menu-view.
  18. ;; 
  19. ;;
  20. ;; See also:
  21. ;; About-marking-menus which describes the underlying concepts
  22. ;; Marking-menu-demo.lisp which contains a full demonstration of marking menus
  23. ;; Hier-menu-demo.lisp which contains a full demonstration of hierarchical
  24. ;;    marking menus 
  25. ;; 
  26. ;; Change history
  27. ;;  1992-05-13  support for automatically sizing menus (:auto-size)
  28. ;;              support of menus with color screens, even when the
  29. ;;              window containing the marking-menu straddles screens
  30. ;;  1992-05-22 compatability features added for MCL2.0f...
  31. ;;
  32. ;; Future enhancements
  33. ;;   support for color menu items within marking-menus
  34. ;;   marking ahead for hierarchical (multi-level) menus
  35. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  36.  
  37. (provide :marking-menus)
  38.  
  39. (eval-when (eval compile)
  40.   (require 'quickdraw)
  41.   (require 'oou-utils))
  42.  
  43. #+mcl-final
  44. (eval-when (eval compile)
  45.   ;; all record definitions are now autoloaded in MCL2.0f 
  46.   (require 'records)
  47.   ;; loop.lisp is automatically loaded when required in MCL2.0f...
  48.   (require :loop))
  49.  
  50. (export '(marking-menu empty-menu-item marking-menu-table marking-menu-view marking-menu-window
  51.           containing-view
  52.           resize-menu
  53.           menu-root)
  54.         :menus)
  55. #|
  56. This mixin extends menus to include marking menus.
  57.  
  58. For details on the underlying concepts see about-marking-menus.
  59.  
  60. Marking-menu                            ; a subclass of menus, not exported
  61. Initargs (in addition to the standard menu initargs)
  62.  
  63.   :menu-diameter                        ; default pop-menu-diameter (170)
  64.      diameter of the circular pop-up marking menu
  65.  
  66.    :auto-size                           ; default t
  67.      automatically compute the diameter of the marking-menu to allow
  68.      enough white space.
  69.  
  70.    :offset                              ; default pop-menu-height (2)
  71.      offset of the black circle underneath
  72.    
  73.    :hole-size                           ; default hole-size (10)
  74.       diameter of the dead zone. Releasing the mouse button in this circle
  75.       selects nothing from the menu
  76.  
  77.    :menu-start-tol                      ; default jitter-tol (5)
  78.       mouse is "still" when menu-start-tol is greater than the sum of the
  79.       horizontal and vertical pixel distance of the current mouse position from
  80.       the mouse position at the start of the time interval.
  81.  
  82.    :menu-font                           ; default  '("Chicago" 12 :SRCOR :PLAIN) 
  83.       font spec for the menu items
  84.  
  85.    :on-axis                             ; default nil
  86.       does first menu slice begin at North? Default is no. A straight up motion
  87.       selects the first item when not on-axis
  88.  
  89.    :pop-up-time                         ; default wait 1/12 second
  90.       elapsed time until menu pops up when the mouse remains at most
  91.       menu-start-tol distance from the initial position (vertical + horizontal)
  92.       units are in internal-time-units-per-second.
  93.  
  94.    :menu-double-click-action     ; default none, no function invoked
  95.       A function to be called when the item is double clicked. The function
  96.       should accept one argument, the item (normally a marking-view). The
  97.       action run is the one associated with the most specific marking-menu-view
  98.  
  99.    :menu-actzone                        ; default nil
  100.       Menu will be active when mouse button is pressed in this rectangle
  101.       (local coordinates, of the form
  102.          (topLeft bottomRight) - the rectangle defined by the two points
  103.  
  104.    :menu-opaque                         ; default nil
  105.       Valid only with floating menus.
  106.       When true, greys out the outer ring of a floating marking menu,
  107.       revealing the context of the menu.
  108.       Otherwise, whites-out the outer ring of the marking menu, obscuring
  109.       the context.
  110.  
  111.    :menu-floating                      ; default t
  112.       Creates a menu which appears to be floating over the view.
  113.       Lines connect the center of the menu item titles to the central hub.
  114.       Otherwise, lines divide the menu so that the title appear in the middle
  115.       of each wedge.
  116.  
  117.    :hide                                ; default t
  118.      hide the other menu items when a menu item corresponding to a menu
  119.      is selected.
  120.  
  121.    :in-position                         ; default nil
  122.      when hide and menu-floating are in effect, places the menu item
  123.      to the left of the central spoke and removes the box
  124.      when in-position is true; otherwise leaves the box around the menu
  125.      item.
  126.    
  127.    :turn                                ; default t
  128.       when turn is in effect, the menus alternate between on and off axis.
  129.       Otherwise, all menus are either on/off axis. For sub menus, the on-axis
  130.       specification is ignored.
  131.  
  132.   :pop-width                            ; default 1/3 * menu-radius
  133.       A hierarchical menu pops up when the mouse is still and the current
  134.       point is more than pop-width pixels from the menu-center.
  135.  
  136. Note: sub-menus inherit the following attributes of the root (parent) menu:
  137.       menu-floating, opaque, hide, in-position turn
  138.  
  139. Marking-menu-view                       ; a marking-menu view, exported
  140.    :initarg         same as marking-menu and view
  141.  
  142.  
  143. Marking-menu-window                     ; a marking-view window, exported
  144.    :initarg         same as marking-menu and window
  145.  
  146. Empty-menu-item                         ; a menu-item, exported
  147.     Use instances of this item to create empty menu items. The item
  148.     will be disabled and will have a title of "-".
  149.  
  150. Methods of interest
  151. Containing view returns the view associated with a menu or the
  152. view associated with a menu of the which the menu-item is a part.
  153.  
  154. (Containing-view marking-menu)
  155. Returns the view associated with the menu.
  156. For a hier-marking-menu, the result is the root of the menu tree.
  157. For all other marking-menus, the result is the marking-menu itself.
  158.  
  159. (Containing-view menu-item)
  160. When the menu-item is associated with a marking-menu, the result
  161. is the containing-view of the marking-menu.
  162.  
  163. Otherwise, the result is the menu associated with the menu-item.
  164.  
  165. Menu-double-click-action
  166. Peforms the action (if any) associated with double-clicking in the
  167. view.
  168.  
  169.    (menu-double-click-action marking-menu)
  170.    When a double-click-function is defined for the markking menu,
  171.    performs the function.
  172.  
  173. Do-menu-item-action
  174. Do-menu-item-action invokes the menu-item-action-function associated
  175. with the menu item with the appropriate paramters. Allows the 
  176. action to be performed with normal menus as well.
  177.  
  178. Note: For functions which change the contents of any view, use 
  179. "eval-enqueue" to ensure that the hierarchical menu is erased
  180. properly before the action is performed. 
  181.  
  182. (do-menu-item-action menu-item)
  183.     Invokes the menu-item-action-function associated with the menu-item
  184.     with no parameters.
  185.  
  186. (do-menu-item-action window-menu-item)
  187.     Invokes the menu-item-action-function associated with the menu-item
  188.     with one parameter - the window-menu-item.
  189.  
  190. (do-menu-item-action marking-menu)
  191.     Has no effect, specialize to perform other actions after selecting
  192.     but not invoking a hier-menu.
  193.  
  194. Resize-menu
  195. (Resize-menu marking-menu-view)
  196. For all marking-menu-views, adjusts the containing menu-rect to
  197. include all of the menu-titles.
  198.  
  199. For auto-size marking-menu-views, adjust the menu-radius and
  200. menu-diameter of the marking-value to allow enough white space 
  201. between each menu item and the inner circle and the outer circle.
  202.  
  203. Set-menu-font
  204. (set-menu-font marking-menu-view font-spect)
  205. Sets the font-spec to be used for the marking menu. Resizes the menu
  206. automatically.
  207.  
  208. menu-root
  209. (menu-root marking-menu-view)
  210. Returns the root of the menu-tree with node
  211.  
  212.  
  213. |#
  214.                                           
  215.  
  216. (defconstant 2pi (* 2 pi) "Radians in a circle")
  217.  
  218. (defconstant full-circle 360 "Degrees in a circle")
  219. (defconstant rads-to-degrees (/ full-circle 2pi))
  220.  
  221. ;; default values for the marking menus
  222. (defconstant hole-size 10)
  223. (defconstant pop-menu-height 2)
  224. (defconstant pop-menu-diameter 170)
  225. (defconstant jitter-tol 5)
  226. (defconstant wait (round internal-time-units-per-second 12) "seconds to wait before popping up the menu")
  227.  
  228. (defvar *arrow*)                        ; a large filled, right-pointing arrow
  229.  
  230. ;; structure for storing points that describe the position of menu-item
  231. ;; rect-top-left       coordinates of the rectangle enclosing the text of the
  232. ;; rect-bot-right                  title with white space
  233.  
  234. ;; text-width          half the width of the text string
  235.  
  236. ;; text-top-left       coordinates of the rectangle enclosing
  237. ;; text-bottom-right               only the text
  238.  
  239. ;; text-center:        the center of the text string 
  240. ;; slice-point:        the point on the outer-most circle that
  241. ;;                     defines the start of the wedge
  242.  
  243. (defstruct (item (:type list))
  244.   (rect-top-left  #@(0 0))
  245.   (rect-bot-right #@(0 0))
  246.   (text-center  #@(0 0))
  247.   (text-width 0)
  248.   (text-start  #@(0 0))
  249.   (text-top-left  #@(0 0))
  250.   (text-bot-right #@(0 0))
  251.   slice-point
  252.   title)
  253.  
  254. ;; a class of menu-items which corresponds to the divider in a pull-down menu
  255. (defclass empty-menu-item (menu-item)
  256.   ()
  257.   (:default-initargs
  258.     :menu-item-title "-"
  259.     :disabled t))
  260.  
  261. (defclass marking-menu (menu)
  262.   ((menu-diameter :initarg :menu-diameter)
  263.    (auto-size :initarg :auto-size)
  264.    (menu-height :initarg :offset)       
  265.    (menu-hole :initarg :hole-size)      
  266.    (menu-start-tol :initarg :menu-start-tol)   
  267.    (menu-font :initarg :menu-font)      
  268.    (on-axis :initarg :on-axis)          
  269.    (pop-up-time :initarg :pop-up-time)
  270.    (menu-double-click-action-function :initarg :menu-double-click-action)
  271.    (menu-actzone :initarg :menu-actzone)
  272.    (menu-floating :initarg :menu-floating)
  273.    (menu-opaque  :initarg :menu-opaque)
  274.    (turn :initarg :turn)
  275.    (hide :initarg :hide)
  276.    (in-position :initarg :in-position)
  277.    (pop-width :initarg :pop-width)
  278.    (viewer :initform nil)               ; containing view
  279.    (menu-title-rect :initform nil)      ; list of topLeft bottomRight coordinates of the
  280.                                         ; rectangles corresponding to the titles
  281.    (menu-radius :initarg nil)           ; radius of the marking menu
  282.    (menu-center  :initform nil)         ; current center of the marking menu
  283.    (menu-rect)                          ; rectangle enclosing the menu centered at #@(0 0)
  284.                                         ; actual rectangle is offset by menu-center
  285.    (saved-bit-map  :initform nil)       ; saved bit map of the screen obscured by the menu
  286.                                         ; corresponding to the actual rectangle
  287.    (arrow-size :initform #@(15 15))     ; dimensions of the arrow indicating a submenu
  288.    (sized :initform nil)                ; has the menu been resized?
  289.    (real-corners :initform nil)         ; corners of enclosing rectangle
  290.    (arrow-indent :initform nil))        ; arrow starts indented arrow-indent from bottom-right 
  291.   (:default-initargs
  292.     :menu-diameter pop-menu-diameter
  293.     :auto-size t
  294.     :offset pop-menu-height
  295.     :menu-start-tol jitter-tol
  296.     :menu-font '("Chicago" 12 :SRCOR :PLAIN)
  297.     :hole-size hole-size
  298.     :on-axis nil
  299.     :pop-up-time wait
  300.     :menu-actzone nil
  301.     :menu-floating t
  302.     :menu-opaque nil
  303.     :hide t
  304.     :turn t
  305.     :in-position t
  306.     :pop-width nil))
  307.  
  308. (defclass marking-menu-view (marking-menu view)
  309.   ())
  310.  
  311. (defclass marking-menu-window (marking-menu-view window)
  312.   ())
  313.  
  314. (defclass marking-menu-table (sequence-dialog-item marking-menu-view)
  315.   ())
  316.  
  317. (defmethod page-forward ((self table-dialog-item))
  318.   (let* ((first-cell (point-h (scroll-position self)))
  319.          (ncells (point-h (table-dimensions self)))
  320.          (visible-dimensions (point-h (visible-dimensions self)))
  321.          (last-cell (min (1- (+ first-cell visible-dimensions))
  322.                          (- ncells visible-dimensions))))
  323.     (when (< last-cell ncells)
  324.       (scroll-to-cell self last-cell)
  325.        (< (+ last-cell visible-dimensions) ncells))))
  326.  
  327. (defmethod page-back ((self table-dialog-item))
  328.   (let* ((first-cell (point-h (scroll-position self)))
  329.          (visible-dimensions (point-h (visible-dimensions self)))
  330.          new-cell)
  331.       (setq new-cell (max 0 (1+ (- first-cell visible-dimensions))))
  332.       (scroll-to-cell self new-cell)
  333.       (not (zerop new-cell))))
  334.  
  335. (defmethod page-down ((self table-dialog-item))
  336.   (let* ((first-cell (point-v (scroll-position self)))
  337.          (ncells (point-v (table-dimensions self)))
  338.          (visible-dimensions (point-v (visible-dimensions self)))
  339.          (last-cell (min (1- (+ first-cell visible-dimensions))
  340.                          (- ncells visible-dimensions))))
  341.     (when (< last-cell ncells)
  342.       (scroll-to-cell self (make-point 1 last-cell))
  343.        (< (+ last-cell visible-dimensions) ncells))))
  344.  
  345. (defmethod page-up ((self table-dialog-item))
  346.   (let* ((first-cell (point-v (scroll-position self)))
  347.          (visible-dimensions (point-v (visible-dimensions self)))
  348.          new-cell)
  349.       (setq new-cell (max 0 (1+ (- first-cell visible-dimensions))))
  350.       (scroll-to-cell self (make-point 1 new-cell))
  351.       (not (zerop new-cell))))
  352.  
  353. (defmethod initialize-instance :after ((view marking-menu-view) &rest init-args)
  354.   (declare (ignore init-args))
  355.   (with-slots (menu-actzone pop-width menu-hole) view
  356.     (unless (numberp pop-width)
  357.       (setq pop-width (+ menu-hole menu-hole)))
  358.     (when menu-actzone
  359.       (let (topLeft bottomRight)
  360.         (if (listp menu-actzone)
  361.           (setq topLeft (first menu-actzone)
  362.                 bottomRight (second menu-actzone))
  363.           (setq topLeft #@(0 0)
  364.                 bottomRight menu-actzone))
  365.         (setq menu-actzone (make-record :rect :topLeft topLeft :bottomRight bottomRight))))))
  366.  
  367. (defmethod remove-menu-view ((menu marking-menu))
  368.   (when (slot-boundp menu 'menu-rect)
  369.     (with-slots (menu-rect) menu
  370.       (without-interrupts
  371.        (when menu-rect
  372.          (with-slots (saved-bit-map menu-actzone) menu
  373.            (when (zone-pointerp menu-rect)
  374.              (dispose-record menu-rect :rect))
  375.            (when (zone-pointerp menu-actzone)
  376.              (dispose-record menu-actzone :rect))
  377.            (setq menu-actzone nil)
  378.            (safe-kill-picture saved-bit-map)
  379.            (slot-makunbound menu 'menu-rect))))
  380.       (dolist (menu-item (menu-items menu))
  381.         (when (is-menu menu-item)
  382.           (remove-menu-view menu-item))))))
  383.  
  384. (defmethod remove-view-from-window ((menu marking-menu))
  385.   ;; remove items from the heap associated with a marking-menu
  386.   (call-next-method)
  387.   (remove-menu-view menu))
  388.  
  389. (defmethod ccl:add-menu-items ((menu marking-menu) &rest menu-items)
  390.   (apply #'call-next-method menu menu-items)
  391.   (mapc  #'(lambda (item)
  392.              (when (is-menu item)
  393.                (resize-menu item)))
  394.          menu-items)
  395.   (resize-menu menu))
  396.  
  397. (defmethod ccl:remove-menu-items ((menu marking-menu) &rest menu-items)
  398.   (apply #'call-next-method menu menu-items)
  399.   (mapc  #'(lambda (item)
  400.              (when (is-menu item)
  401.                (remove-menu-view item)))
  402.          menu-items)
  403.   (resize-menu menu))
  404.  
  405. (defmethod set-menu-item-title (menu-item title)
  406.   (apply #'call-next-method menu-item title)
  407.   (let ((menu (menu-owner menu-item)))
  408.     (resize-menu menu)))
  409.  
  410. (defmethod set-menu-font ((menu marking-menu-view) font-spec)
  411.   (setf (slot-value menu 'menu-font) (append font-spec '(:plain)))
  412.   (set-arrow-size menu :force t)
  413.   (resize-menu menu))
  414.  
  415. (defmethod menu-root ((menu marking-menu-view))
  416.   (let (next-menu)
  417.     (when menu
  418.       (loop 
  419.         while (setq next-menu (menu-owner menu))
  420.         finally  (return menu)
  421.         do (setq menu next-menu)))))
  422.  
  423. ;; routines for creating, drawing, deleting arrows
  424. (defun get-arrow ()
  425.   ;; Create a filled right pointing arrow for a line-height of 256
  426.   (unless (and (boundp '*arrow*) (handlep *arrow*))
  427.     (with-wmgr-view 
  428.       (let* ((unit 32)
  429.              (floor-unit (make-point (+ unit 64) 32))
  430.              (floor-three-unit (* 3 unit))
  431.              my-poly
  432.              (wptr (wptr *wmgr-view*))
  433.              pict)
  434.         (rlet ((r :rect :topLeft #@(0 0) :bottomRight #@(255 255)))
  435.           (with-clip-rect r
  436.             (with-port wptr
  437.               (setq my-poly (#_OpenPoly)))
  438.             (#_MoveTo :long floor-unit)
  439.             (#_Line 0 (* 6 unit))
  440.             (#_Line floor-three-unit (- floor-three-unit))
  441.             (#_LineTo :long floor-unit)
  442.             (with-port wptr
  443.               (#_ClosePoly))
  444.             (setq pict (#_OpenPicture :ptr r))
  445.             (#_PaintPoly :ptr my-poly)
  446.             (#_closePicture)
  447.             (#_KillPoly :ptr my-poly)
  448.             (setq *arrow* pict)))))))
  449.  
  450. (defmethod set-arrow-size ((menu marking-menu) &key force)
  451.   (get-arrow)
  452.   (unless (or force (slot-boundp menu 'arrow-size))
  453.     (setf (slot-value menu 'arrow-size)
  454.           (compute-arrow-size menu))))
  455.  
  456. (defmethod compute-arrow-size ((menu marking-menu))
  457.   (with-slots (menu-font) menu
  458.     (let* ((top-left (href *arrow* :picture.picframe.topleft))
  459.            (bottom-right (href *arrow* :picture.picframe.BottomRight))
  460.            (size (subtract-points bottom-right top-left))
  461.            (line-height (font-line-height menu-font))
  462.            (factor (/ line-height 256)))
  463.       (make-point (round (1+ (* factor (point-h size))))
  464.                   (round (1+ (* factor (point-v size))))))))
  465.  
  466. (defun delete-arrow ()
  467.   (when (and (boundp '*arrow*) (handlep *arrow*))
  468.     (kill-picture *arrow*))
  469.   (makunbound '*arrow*))
  470.  
  471. (defun draw-arrow (new-size position)
  472.   ;; draws the arrow with at the position, at size new-size
  473.   (rlet ((r :rect :topLeft position
  474.             :bottomRight (add-points position new-size)))
  475.     (#_drawPicture :ptr *arrow* :ptr r)))
  476.  
  477. (defmethod get-arrow-size ((menu marking-menu))
  478.   )
  479.  
  480. (defmethod containing-view ((menu marking-menu))
  481.   ;; find the view containing the marking-menu
  482.   (let ((viewer (when (slot-exists-p menu 'viewer)
  483.                   (slot-value menu 'viewer))))
  484.     (if viewer viewer menu)))
  485.  
  486. (defmethod containing-view ((ccl::menu-element menu-item))
  487.   ;; find the view containing the marking-menu
  488.   (let* ((owner (menu-item-owner ccl::menu-element)))
  489.     (containing-view owner)))
  490.  
  491. (defun point-box (x)
  492.   "construct the point #@(x x)"
  493.   (make-point x x))
  494.  
  495. (defmethod init-menu-box ((menu marking-menu))
  496.   ;; Fills in the menu slots after the first mouse click in the marking view
  497.   (with-slots (saved-bit-map menu-center sized) menu
  498.     (unless sized 
  499.       (resize-menu menu))
  500.     (safe-kill-picture saved-bit-map)
  501.     (setq menu-center nil)))
  502.  
  503. (defmethod check-menu-box ((menu marking-menu) &optional flag)
  504.   (unless (slot-boundp menu 'menu-rect)
  505.     (init-menu-box menu)
  506.     (when flag
  507.       (print-db menu))))
  508.  
  509. (defmethod resize-menu ((menu marking-menu))
  510.   ;; For auto-size marking-menus
  511.   ;;   Calculates the menu-diameter and menu-radius of a marking-menu,
  512.   ;;   allowing enough whitespace
  513.   ;; Ensures that the menu-item titles fit inside the circle associated
  514.   ;; with the menu-rect (radius = (1- (abs (point-h top-left-corder)))
  515.   (let* ((n-items (length (menu-items menu)))
  516.          (do-size (slot-value menu 'auto-size))
  517.          menu-rect)
  518.     (set-arrow-size menu)
  519.     (setf (slot-value menu 'menu-radius)
  520.           (truncate (slot-value menu 'menu-diameter) 2))
  521.     (if (> n-items 0)
  522.       (with-slots (menu-diameter menu-hole) menu
  523.         (with-slots (menu-font sized arrow-size arrow-indent) menu
  524.           (multiple-value-bind (ascent descent) (font-info menu-font)
  525.             (let* ((border descent)
  526.                    (theta/2 (/ pi n-items))
  527.                    width-list)
  528.               (when (menu-owner menu) (menu-item-enable menu))
  529.               (when do-size
  530.                 (setq menu-diameter (ash menu-hole 3))
  531.                 (setf (slot-value menu 'menu-radius) (ash menu-diameter -1)))
  532.               (setq arrow-indent (make-point (+ border (point-h arrow-size))
  533.                                              (+ border descent ascent))
  534.                     width-list (menu-calc-widths menu :full t)
  535.                     sized t)
  536.               (when do-size
  537.                 (menu-calc-rect menu ascent descent border width-list theta/2))
  538.               (menu-calc-outer menu ascent descent border width-list theta/2)
  539.               (init-menu-box menu)))))
  540.       (with-slots (saved-bit-map menu-center) menu
  541.         ;; no items in the menu, disable the menu if it is submenu
  542.         (when (menu-owner menu) (menu-item-disable menu))
  543.         (when (and (slot-boundp menu 'menu-rect)
  544.                    (setq menu-rect (slot-value menu 'menu-rect))
  545.                    (zone-pointerp menu-rect))
  546.           (dispose-record menu-rect :rect)
  547.           (slot-makunbound menu 'menu-rect))
  548.         (safe-kill-picture saved-bit-map)
  549.         (setq menu-center nil)))))
  550.  
  551. (defmethod menu-calc-widths ((menu marking-menu) &key full)
  552.   ;;Returns a list with the half widths of the menu-item-titles including white space
  553.   (with-slots (menu-font arrow-size) menu
  554.     (let (style width half-width string font-spec width-list)
  555.       (dolist (menu-item (menu-items menu))
  556.         (setq string (format nil "~a" (menu-item-title menu-item)))
  557.         (unless (equal string "-")
  558.           (when (and full (slot-exists-p menu-item 'check-mark-char))
  559.             (setq string (format nil "~a ~a" (slot-value menu-item 'check-mark-char) string))))
  560.         (setq style (menu-item-style menu-item)
  561.               font-spec (if style (append menu-font (list (menu-item-style menu-item)))
  562.                             menu-font))
  563.         (with-font-spec font-spec
  564.           (with-returned-pstrs ((text-buff string))
  565.             (setq width (#_TextWidth :ptr text-buff :integer 1 :integer (length string)))
  566.             (when (is-menu menu-item)
  567.               (incf width (point-h arrow-size)))
  568.             (setq half-width (ash (1+ width) -1))))
  569.         (push half-width width-list))
  570.       (setq width-list (nreverse width-list)))))
  571.  
  572. (defun init-text-rect (text-box ascent descent border half-width)
  573.   (rset text-box :rect.topLeft (make-point (- half-width) (- ascent)))
  574.   (rset text-box :rect.bottomRight 
  575.         (make-point (+ border half-width)
  576.                     (+ border descent)))
  577.   (#_InsetRect :ptr text-box :long (point-box (- border))))
  578.  
  579. (defun on-axis (menu &optional (flag t))
  580.   (if (null menu)
  581.     flag
  582.     (let ((next (when (and menu (slot-exists-p menu 'ccl::owner))
  583.                   (slot-value menu 'ccl::owner))))
  584.       (cond ((null next)
  585.              (if flag (not (slot-value menu 'on-axis))
  586.                  (slot-value menu 'on-axis)))
  587.             ((slot-value menu 'turn)
  588.              (if next
  589.                (on-axis next (not flag))
  590.                (if flag (not (slot-value menu 'on-axis))
  591.                    (slot-value menu 'on-axis))))
  592.             (t flag)))))
  593.  
  594. (defmethod menu-calc-rect ((menu marking-menu) ascent descent border width-list theta/2)
  595.   ;; adjusts circle with menu-radius so that the boxes including the menu-item-titles
  596.   ;;  and white space satisfy the following conditions:
  597.   ;;  1. The center of the base line of the text lies along a circle of radius menu-radius.
  598.   ;;  2. The right and left halves of the text box cast a shadow of at most 180/#menu-items
  599.   ;;     with a point light source at (0,0)
  600.   ;;  3. Each text box has enough whitespace between it and the central circle.
  601.   ;;     The text box lies outside a square centered at the origin with sides 2*menu-hole
  602.   (with-slots (menu-radius menu-diameter menu-hole) menu
  603.     (let* (angle
  604.            (start-radius menu-radius)
  605.            (min-move 1)
  606.            (hole-space (ash menu-hole 0))
  607.            x 
  608.            y 
  609.            text-center 
  610.            old-center
  611.            (turn-before (on-axis menu))
  612.            ;(half-degrees (* theta/2 rads-to-degrees))
  613.            ;mid-slice
  614.            offset)
  615.       (rlet ((r :rect :topLeft (point-box (- menu-radius))
  616.                 :bottomRight (point-box menu-radius))
  617.              (text-box :rect)
  618.              (hole-box :rect :topLeft (point-box (- hole-space))
  619.                        :bottomRight (point-box hole-space))
  620.              (u-rect :rect :topLeft #@(0 0) :bottomRight #@(0 0)))
  621.         (setq angle (if turn-before (- theta/2)
  622.                         0))
  623.         (dolist (half-width width-list)
  624.           (incf angle theta/2)
  625.           (init-text-rect text-box ascent descent border half-width)
  626.           (setq old-center #@(0 0))
  627.           (loop 
  628.             do (progn (setq x (least-integer (* (sin angle) menu-radius))
  629.                             y (least-integer (* (cos angle) menu-radius))
  630.                             text-center (make-point x (- y))
  631.                             offset (subtract-points text-center old-center))
  632.                       (#_offsetRect :ptr text-box :long offset)
  633.                       (intersect-rect hole-box text-box u-rect)
  634.                       (unless (empty-rect-p u-rect)
  635.                         (setq menu-radius (increase-radius r menu-radius min-move))))
  636.             
  637.             until (box-rad text-box angle theta/2)
  638.             finally (return t)
  639.             
  640.             do (setq menu-radius (increase-radius r menu-radius min-move)
  641.                      old-center text-center))
  642.           (incf angle theta/2))
  643.         (setq menu-diameter (ash menu-radius 1))
  644.         (= menu-radius start-radius)))))
  645.  
  646. (defun least-integer (x)
  647.   (if (minusp x) (floor x)
  648.       (ceiling x)))
  649.  
  650. (defun rads-to-degrees (rads)
  651.   (* rads rads-to-degrees))
  652.  
  653. (defmethod menu-calc-outer ((menu marking-menu) ascent descent border width-list theta/2)
  654.   ;; compute the smallest square surrounding the text-boxes in the menu,
  655.   ;; centered at #@(0 0)
  656.   (unless (and (slot-boundp menu 'menu-rect)
  657.                (zone-pointerp (slot-value menu 'menu-rect)))
  658.     (setf (slot-value menu 'menu-rect) (make-record :rect)))
  659.   (with-slots (menu-radius menu-rect menu-height real-corners) menu
  660.     (rlet ((u-rect :rect :topLeft #@(0 0) :bottomRight #@(0 0))
  661.            (text-box :rect))
  662.       (let ((angle (if (on-axis menu) (- theta/2)
  663.                        0))
  664.             real-angle
  665.             x 
  666.             y 
  667.             text-center
  668.             real-radius)
  669.         (dolist (half-width width-list)
  670.           (incf angle theta/2)
  671.           (setq real-angle angle)
  672.           (setq x (truncate (* (sin real-angle) menu-radius))
  673.                 y (truncate (* (cos real-angle) menu-radius))
  674.                 text-center (make-point x (- y)))
  675.           (rset text-box :rect.topLeft (make-point (- half-width) (- 0 ascent)))
  676.           (rset text-box :rect.bottomRight (make-point (+ border half-width)
  677.                                                        (+ border descent)))
  678.           (#_insetRect :ptr text-box :long (point-box (- border)))
  679.           (#_offsetRect :ptr text-box :long text-center)
  680.           (union-rect u-rect text-box u-rect)
  681.           (incf angle theta/2))
  682.         (make-square-rect u-rect)       ; enclose the title rectangles in a square
  683.         (setq real-corners (list (rref u-rect :rect.TopLeft) (rref u-rect :rect.bottomRight)))
  684.         (setq real-radius (point-h (rref u-rect :rect.bottomRight)))
  685.         (rset menu-rect 
  686.               :rect.topLeft (point-box (1- (- real-radius))))
  687.         (rset menu-rect
  688.               :rect.bottomRight (point-box (+ (* 2 menu-height) real-radius)))))))
  689.  
  690. (defun make-square-rect (r)
  691.   "Adjust the rectangle r centered at #@(0 0)
  692.   to the smallest square such that an inscribed circle
  693.   encloses the original rectangle."
  694.   (multiple-value-bind (p1 p2 p3 p4)
  695.                        (rect-corners r)
  696.     (let ((max 0) 
  697.           dim-h dim-v)
  698.       (dolist (p (list p1 p2 p3 p4))
  699.         (setq dim-h (point-h p)
  700.               dim-v (point-v p))
  701.         (setq max (max max (+ (* dim-h dim-h) (* dim-v dim-v)))))
  702.       (setq max (isqrt  max))
  703.       (rset r :rect.topLeft (point-box (- max)))
  704.       (rset r :rect.bottomRight (point-box max)))))
  705.  
  706. (defun rect-corners (r)
  707.   "Return the four points corresponding to the corners of the rectangle r
  708.    in the clockwise direction starting with the top-left"
  709.   (let* ((top-left (rref r :rect.topLeft))
  710.          (bottom-right (rref r :rect.bottomRight))
  711.          (top (point-v top-left))
  712.          (bottom (point-v bottom-right))
  713.          (left (point-h top-left))
  714.          (right (point-h bottom-right)))
  715.     (values top-left bottom-right (make-point right top) (make-point left bottom))))
  716.  
  717.  
  718. (defun included-angle (angle)
  719.   (if (minusp angle) 
  720.     (included-angle (- angle))
  721.     (if (>= angle pi)
  722.       (included-angle (- angle 2pi))
  723.       angle)))
  724.  
  725. (defun included-arc (degrees)
  726.   (if (minusp degrees) 
  727.     (included-arc (- degrees))
  728.     (if (>= degrees 180)
  729.       (included-arc (- degrees 360))
  730.       degrees)))
  731.  
  732. (defun point-angle (p1 p2)
  733.   "The angle between the directed line p1 and p2 relative to the vertical line"
  734.   (let* ((diff (subtract-points p2 p1))
  735.          (diff-h (point-h diff))
  736.          (diff-v (point-v diff))
  737.          angle)
  738.     (setq angle (atan diff-h (- diff-v)))
  739.     (when (minusp angle)
  740.       (incf angle 2pi))
  741.     angle))
  742.  
  743. (defun box-angle (hole-box text-box mid-slice half-degrees)
  744.   "Compute the angle of the shadow cast by the rectangle text-box
  745.    and the point light source at the center of the square r
  746.    return t when the angle is <= degrees"
  747.   (let (angle)
  748.     (multiple-value-bind (top-left top-right bottom-right bottom-left)
  749.                          (rect-corners text-box)
  750.       (dolist (point (list top-left top-right bottom-right bottom-left))
  751.         (setq angle (point-to-angle hole-box point))
  752.         (when (> (included-arc (- angle mid-slice)) half-degrees)
  753.           (return-from box-angle nil)))
  754.       t)))
  755.  
  756. (defun box-rad (text-box angle theta/2)
  757.   "Compute the angle of the shadow cast by the rectangle text-box
  758.    and the point light source at the center of the square r
  759.    return t when the angle is <= degrees"
  760.   (let (new-angle)
  761.     (multiple-value-bind (top-left top-right bottom-right bottom-left)
  762.                          (rect-corners text-box)
  763.       (dolist (point (list top-left top-right bottom-right bottom-left))
  764.         (setq new-angle (point-angle #@(0 0) point))
  765.         (when (>= (included-angle (- angle new-angle)) theta/2)
  766.           (return-from box-rad nil)))
  767.       t)))
  768.  
  769. (defun increase-radius (r radius amount)
  770.   (when (and amount (numberp amount) (> amount 0))
  771.     (incf radius amount)
  772.     (inset-rect r (point-box (- amount))))
  773.   radius)
  774.  
  775. (defun get-max-dim (r)
  776.   (let* ((top-left (rref r :rect.topLeft))
  777.          (bottom-right (rref r :rect.bottomRight))
  778.          (dim (subtract-points bottom-right top-left)))
  779.     (max (point-h dim) (point-v dim))))
  780.  
  781.  
  782. (defun draw-hole (menu r)
  783.   (with-slots (menu-center menu-hole menu-floating) menu
  784.     (let ((hole-box (point-box menu-hole)))
  785.       (rset r :rect.topLeft (subtract-points menu-center hole-box))
  786.       (rset r :rect.bottomRight (add-points menu-center hole-box))
  787.       (when menu-floating
  788.         (#_offsetRect :ptr r :long #@(2 2))
  789.         (#_fillOval :ptr r :ptr *black-pattern*)
  790.         (#_offsetRect :ptr r :long #@(-2 -2)))
  791.       (#_EraseOval :ptr r)
  792.       (#_frameOval :ptr r))))
  793.  
  794. (defun get-radius-box (menu)
  795.   (with-slots (menu-rect) menu
  796.     (subtract-points #@(-1 -1) (rref menu-rect :rect.topLeft))))
  797.  
  798. (defmethod display-marking-menu ((menu marking-menu))
  799.   ;; displays the circular marking menu
  800.   (with-slots (on-axis menu-rect menu-center menu-diameter menu-floating menu-opaque
  801.                        menu-font menu-radius menu-height menu-title-rect
  802.                        arrow-size real-corners) menu
  803.     (let* ((center (make-point (add-points 
  804.                                 (add-points (point-box (- menu-radius))
  805.                                             (point-box (truncate (/ menu-diameter 2))))
  806.                                 menu-center)))
  807.            (menu-items (menu-items menu))
  808.            (size (length menu-items))
  809.            (radius-box (get-radius-box menu))
  810.            (real-radius (point-h radius-box))
  811.            (theta/2 (/ pi size))
  812.            (theta (* 2 theta/2))
  813.            (angle 0)
  814.            (center-h (point-h center))
  815.            (center-v (point-v center))
  816.            font-spec
  817.            real-angle
  818.            ascent
  819.            descent
  820.            border
  821.            style
  822.            item-spec)
  823.       (with-pen-state (:pnmode #$patCopy :pnPat *black-pattern*)
  824.       (rlet ((r :rect :topLeft (subtract-points center radius-box)
  825.                 :bottomRight (add-points (add-points center radius-box) #@(1 1)))
  826.              (clip-rect1 :rect))
  827.         
  828.         (if menu-floating
  829.           (progn (rset clip-rect1 :rect.topLeft (first real-corners))
  830.                  (rset clip-rect1 :rect.bottomRight (second real-corners)))
  831.           (copy-record menu-rect :rect clip-rect1))
  832.         (#_offsetRect :ptr clip-rect1 :long center)
  833.         (with-clip-rect clip-rect1
  834.           (cond (menu-opaque
  835.                  (without-interrupts 
  836.                   (with-pen-state (:pnMode #$patBic :pnPat *light-gray-pattern*)
  837.                     (#_OffsetRect :ptr  r :long (point-box menu-height))
  838.                     (if menu-floating
  839.                       (#_PaintRect :ptr r)
  840.                       (#_PaintOval :ptr r)))
  841.                   (#_OffsetRect :ptr r :long (point-box (- menu-height)))
  842.                   (unless menu-floating
  843.                     (#_frameOval :ptr r))))
  844.                 (menu-floating t)
  845.                 (t (without-interrupts 
  846.                     (#_OffsetRect :ptr  r :long (point-box menu-height))
  847.                     (#_PaintOval :ptr r)
  848.                     (#_OffsetRect :ptr r :long (point-box (- menu-height)))
  849.                     (#_EraseOval :ptr r)
  850.                     (#_FrameOval :ptr r))))
  851.           (unless on-axis (setq angle (decf angle theta/2)))
  852.           (setq menu-title-rect nil)
  853.           (with-font-spec menu-font
  854.             (multiple-value-setq (ascent descent) (font-info))
  855.             (setq border descent)
  856.             (dolist (item menu-items)
  857.               (setq style (menu-item-style item)
  858.                     font-spec (if style (append menu-font (list (menu-item-style item)))
  859.                                   menu-font))
  860.               (with-font-spec font-spec
  861.                 (setq real-angle angle
  862.                       item-spec
  863.                       (calc-menu-item r menu-radius real-radius center-h center-v theta/2
  864.                                       real-angle ascent descent border
  865.                                       item menu-floating arrow-size))
  866.                 (draw-title menu item item-spec t)
  867.                 (push item-spec menu-title-rect))
  868.               (incf angle theta))
  869.             (setq menu-title-rect (nreverse menu-title-rect))
  870.             (draw-hole menu r))))))))
  871.  
  872. (defun calc-menu-item (r menu-radius real-radius center-h center-v theta/2
  873.                          real-angle ascent descent border 
  874.                          menu-item menu-floating arrow-size)
  875.   (let (width x y string menu-item-enabled new-point
  876.               top-left bottom-right text-center slice-point
  877.               text-top text-bot
  878.               check-mark
  879.               arrow-width
  880.               half-width)
  881.     (unless menu-floating
  882.       (setq x (truncate (* (sin real-angle) real-radius))
  883.             y (truncate (* (cos real-angle) real-radius))
  884.             new-point (make-point (+ x center-h) (- center-v y))
  885.             slice-point new-point))
  886.     (incf real-angle theta/2)
  887.     (setq x (truncate (* (sin real-angle) menu-radius))
  888.           y (truncate (* (cos real-angle) menu-radius))
  889.           string (format nil "~a" (menu-item-title menu-item))
  890.           menu-item-enabled (menu-item-enabled-p menu-item))
  891.     (when (and menu-floating (equal string "-"))
  892.       (return-from calc-menu-item (make-item :slice-point slice-point)))
  893.     (unless (equal string "-")
  894.       (when (slot-exists-p menu-item 'check-mark-char)
  895.         (when (setq check-mark (menu-item-check-mark menu-item))
  896.           (setq string (format nil "~a ~a" check-mark string)))))
  897.     (with-returned-pstrs ((text-buff string))
  898.       (setq width (#_TextWidth :ptr text-buff :integer 1 :integer (length string))
  899.             text-center (make-point (+ x center-h) (- center-v y)))
  900.       (when (is-menu menu-item)
  901.         (setq arrow-width (point-h arrow-size))
  902.         (incf width arrow-width))
  903.       (setq half-width (ash (1+ width) -1))
  904.       (decf x half-width)
  905.       (setq new-point (make-point (+ x center-h) (- center-v y)))
  906.       (rset r :rect.topLeft (make-point (- half-width) (- ascent)))
  907.       (rset r :rect.bottomRight (make-point half-width descent))
  908.       (#_insetRect :ptr r :long (point-box (- border)))
  909.       (#_offsetRect :ptr r :long text-center)
  910.       (setq top-left (rref r :rect.topLeft)
  911.             bottom-right (rref r :rect.bottomRight)
  912.             text-top (subtract-points text-center (make-point half-width ascent))
  913.             text-bot (add-points  text-center (make-point half-width descent)))
  914.       ; handle disabled items
  915.       (unless menu-item-enabled
  916.         (rset r :rect.topLeft text-top)
  917.         (rset r :rect.bottomRight text-bot)
  918.         ( #_InsetRect :ptr r :long #@(0 -1))
  919.         (with-pen-state (:pnPat *gray-pattern* :pnMode #$PatBic)
  920.           (#_PaintRect :ptr r)))
  921.       (make-item :rect-top-left top-left
  922.                  :rect-bot-right bottom-right
  923.                  :text-center text-center
  924.                  :text-width half-width
  925.                  :text-start new-point
  926.                  :slice-point slice-point
  927.                  :text-top-left text-top
  928.                  :text-bot-right text-bot
  929.                  :title string))))
  930.  
  931.  
  932. (defun draw-title (menu menu-item item-spec &optional in-place hilite)
  933.   (with-slots (menu-hole menu-opaque menu-floating arrow-size arrow-indent) menu
  934.     (let* ((menu-item-enabled (menu-item-enabled-p menu-item)) 
  935.            (center (slot-value menu 'menu-center))
  936.            (top-left (item-rect-top-left item-spec))
  937.            (bottom-right (item-rect-bot-right item-spec))
  938.            (text-top-left (item-text-top-left item-spec))
  939.            (text-bot-right (item-text-bot-right item-spec))
  940.            (half-width (item-text-width item-spec))
  941.            (slice-point (item-slice-point item-spec))
  942.            (menu-item-title (item-title item-spec))
  943.            (in-position (or (not (slot-value menu 'menu-floating))
  944.                             (when (slot-exists-p menu 'in-position)
  945.                               (slot-value menu 'in-position))))
  946.            (text-center (item-text-center item-spec))
  947.            (new-center (if (or in-place in-position)
  948.                           text-center
  949.                           (subtract-points center (make-point (+ half-width menu-hole 5) 0))))
  950.            (new-point (subtract-points new-center half-width)))
  951.       (when slice-point
  952.         (#_MoveTo :long center)
  953.         (#_LineTo :long slice-point)) 
  954.       (when (null menu-item-title)
  955.         (return-from draw-title t))
  956.       (rlet ((r :rect :topLeft top-left :bottomRight bottom-right))
  957.         (with-pen-state (:pnPat *black-pattern*
  958.                                 :pnMode #$patCopy))
  959.         (if (or in-position in-place)
  960.           (when menu-floating
  961.             (#_MoveTo :long center)
  962.             (#_LineTo :long text-center) 
  963.             (#_offsetRect :ptr r :long #@(2 2))
  964.             (#_paintRect :ptr r)
  965.             (#_offsetRect :ptr r :long #@(-2 -2)))
  966.           (#_offsetRect :ptr r :long (subtract-points new-center
  967.                                                       text-center)))
  968.         (when (or menu-floating menu-opaque) 
  969.           (#_eraseRect :ptr r))
  970.         (when menu-floating
  971.           (#_frameRect :ptr r))
  972.         (with-font-spec (slot-value menu 'menu-font)
  973.           (with-returned-pstrs ((text-buff menu-item-title))
  974.             (#_MoveTo :long new-point)
  975.             (#_DrawText :ptr text-buff :integer 1 :integer (length menu-item-title))))
  976.         (when (is-menu menu-item)
  977.           (setq new-point (subtract-points (rref r :rect.bottomRight)
  978.                                       arrow-indent))
  979.           (draw-arrow arrow-size new-point)
  980.           (unless (menu-items menu-item)
  981.             (setq menu-item-enabled nil)
  982.             (menu-item-disable menu-item)))
  983.  
  984.         (unless menu-item-enabled
  985.           (rset r :rect.topLeft text-top-left)
  986.           (rset r :rect.bottomRight text-bot-right)
  987.           (#_InsetRect :ptr r :long #@(0 -1))
  988.           (with-pen-state (:pnPat *gray-pattern* :pnMode #$PatBic)
  989.             (#_PaintRect :ptr r)))
  990.         (when hilite (#_invertRect :ptr r))))))
  991.  
  992. (defmethod mouse-position ((menu marking-menu) &optional point)
  993.   ;; convert current mouse position to global coordinates
  994.   (let ((viewer (when (slot-boundp menu 'viewer) 
  995.                   (slot-value menu 'viewer))))
  996.     (unless viewer (setq viewer menu))
  997.     (local-to-global viewer (if point point
  998.                                 (view-mouse-position viewer)))))
  999.  
  1000. (defmethod selected-slice ((menu marking-menu) &key position)
  1001.   ;;Returns the menu-item number corresponding to the selection
  1002.   (with-slots (on-axis menu-center) menu
  1003.     (unless (in-the-hole menu)
  1004.       (let* ((mouse-loc (if position position (mouse-position menu)))
  1005.              (size (length (menu-items menu)))
  1006.              (diff (subtract-points mouse-loc menu-center))
  1007.              theta)
  1008.         (setq theta (atan (point-h diff) (- (point-v diff))))
  1009.         (when (minusp theta)
  1010.           (incf theta 2pi))
  1011.         (unless on-axis
  1012.           (incf theta (/ pi size)))
  1013.         (when (> theta 2pi)
  1014.           (decf theta 2pi))
  1015.         (mod (truncate theta (/ 2pi size)) size)))))
  1016.  
  1017. (defun get-menu-item-rect (menu-title-rect item)
  1018.   (let ((value (nth item menu-title-rect)))
  1019.     (values (item-rect-top-left value) (item-rect-bot-right value))))
  1020.  
  1021. (defmethod invert-item ((menu marking-menu) item)
  1022.   ;; inverts the pixels in the displayed marking menu corresponding to the item number
  1023.   (unless (null item)
  1024.     (with-slots (on-axis menu-center menu-floating menu-opaque menu-title-rect) menu
  1025.       (when (menu-item-enabled-p (nth item (menu-items menu)))
  1026.         (if (or menu-floating menu-opaque)
  1027.           (multiple-value-bind (top-left bottom-right)
  1028.                                (get-menu-item-rect menu-title-rect item)
  1029.             (rlet ((r :rect 
  1030.                       :topLeft top-left
  1031.                       :bottomRight bottom-right))
  1032.               (#_InvertRect :ptr r)))
  1033.           (let* ((size (length (menu-items menu)))
  1034.                  (radius-box (get-radius-box menu))
  1035.                  (slice-size (/ full-circle size))
  1036.                  (start-angle (* item slice-size)))
  1037.             (rlet ((r :rect 
  1038.                       :topLeft (subtract-points menu-center radius-box)
  1039.                       :bottomRight (add-points (add-points menu-center radius-box) #@(1 1))))
  1040.               (unless on-axis (decf start-angle (/ slice-size 2)))
  1041.               (when (minusp start-angle)
  1042.                 (incf start-angle full-circle))
  1043.               (#_InvertArc :ptr r :signed-integer (truncate start-angle) 
  1044.                :signed-integer (truncate slice-size)))))))))
  1045.  
  1046. (defun in-the-hole (menu)
  1047.   ;; determines whether the current mouse position is in the center of the menu
  1048.   (with-slots (menu-center menu-hole) menu
  1049.     (let* ((diff (subtract-points (mouse-position menu) menu-center)))
  1050.       (< (+ (abs (point-h diff)) (abs (point-v diff))) menu-hole))))
  1051.  
  1052. (defmethod mark-stroke ((menu marking-menu) start-point)
  1053.   ;; leaves a ink trail on the screen until the mouse button is released
  1054.   ;; or the mouse remains in roughly the same spot for a dwell time.
  1055.   (let ((prev-loc start-point)
  1056.         loc condition
  1057.         stroke)
  1058.     (with-pen-state (:pnMode #$patxor)
  1059.       (push start-point stroke)
  1060.       (setq loc prev-loc)
  1061.       (#_MoveTo :long start-point) 
  1062.       (loop
  1063.         do (setq loc (mouse-position menu))
  1064.         until (and (mouse-still menu) (setq condition 'still))
  1065.         while (#_WaitMouseUp)
  1066.         finally (return t)
  1067.         do (unless (equal loc prev-loc)
  1068.              (#_LineTo :long prev-loc)
  1069.              (#_LineTo :long loc)
  1070.              (push loc stroke)
  1071.              (setq prev-loc loc)))
  1072.       (values stroke
  1073.               condition
  1074.               loc))))
  1075.  
  1076. (defun erase-stroke (stroke)
  1077.   ;; erases the marks made by mark-stroke
  1078.   (when stroke
  1079.     (let (point last-point)
  1080.       (setq stroke (nreverse stroke))
  1081.       (with-pen-state (:pnMode #$patxor)
  1082.         (setq last-point (first stroke))
  1083.         (#_MoveTo :long last-point)
  1084.         (loop
  1085.           while stroke
  1086.           finally (return t)
  1087.           do (#_LineTo :long last-point)
  1088.           (setq point (pop stroke)
  1089.                 last-point point)
  1090.           (#_LineTo :long point))))))
  1091.  
  1092. (defvar *marking-menu-class* (make-instance 'marking-menu))
  1093.  
  1094. (defmethod find-marking-menu ((menu marking-menu) where)
  1095. ;; find the deepest marking menu containing the point within the view
  1096. ;; associated with the menu
  1097.   (let ((sv (find-view-containing-point menu where)))
  1098.     (loop
  1099.       until (or (eq sv menu) (null sv)
  1100.                 (and (member *marking-menu-class* (class-precedence-list (class-of sv)))
  1101.                      (setq menu sv)))
  1102.       finally (return menu)
  1103.       do (setq sv (view-container sv)))))
  1104.  
  1105. (defmethod menu-double-click-action ((menu marking-menu))
  1106.   (when (slot-boundp menu 'menu-double-click-action-function)
  1107.     (funcall (slot-value menu 'menu-double-click-action-function) menu)))
  1108.  
  1109. (defmethod do-menu-item-action ((ccl::menu-element menu-item) &optional param)
  1110.   (declare (ignore param))
  1111.   (let ((menu-item-action (menu-item-action-function ccl::menu-element)))
  1112.     (when menu-item-action (funcall menu-item-action))))
  1113.  
  1114. (defmethod do-menu-item-action ((menu-item window-menu-item) &optional param)
  1115.   (let ((menu-item-action (menu-item-action-function menu-item)))
  1116.     (when menu-item-action (funcall menu-item-action param))))
  1117.  
  1118. (defmethod do-menu-item-action ((marking-menu marking-menu-view) &optional param)
  1119.   (declare (ignore marking-menu param))
  1120.   nil)
  1121.  
  1122. (defmethod view-click-event-handler  ((menu marking-menu) where)
  1123.   ;; handles mouse clicks in marking-menus associated with marking-menu-views
  1124.   ;; the most specifc subview with view-click-event-handlers overrides the
  1125.   ;; containing view with a marking menu associated with it.
  1126.   (call-next-method menu where)
  1127.   (marking-menu-track menu where))
  1128.  
  1129. (defmethod view-click-event-handler ((marking-menu marking-menu-table) where) 
  1130.   ;; handles mouse clicks in marking-menu-tables
  1131.   ;; since there are no subviews, this routine handles the clicks in
  1132.   ;; the content area (e.g. the cells and not in the thumbs/scrollbars)
  1133.   (let* ((sv marking-menu)
  1134.          (point (convert-coordinates where (view-container sv) sv))
  1135.          (the-cell (point-to-cell sv where)))
  1136.     (if (equal (slot-value sv 'ccl::selection-type) :single)
  1137.       (if  the-cell
  1138.         (progn
  1139.           (mapc #'(lambda (u)
  1140.                     (unless (eq u the-cell)
  1141.                       (cell-deselect sv u)))
  1142.                 (selected-cells sv))
  1143.           (unless (cell-selected-p sv the-cell)
  1144.             (cell-select sv the-cell))
  1145.           (marking-menu-track sv point))   ; invoke the marking menu
  1146.         (call-next-method marking-menu where))
  1147.       (call-next-method marking-menu where))))
  1148.  
  1149. (defmacro with-saved-bit-map ((menu &key center)
  1150.                               &rest body)
  1151.   `(with-Wmgr-view
  1152.      (with-slots (menu-center saved-bit-map) ,menu
  1153.        (unwind-protect
  1154.          (progn (check-menu-box ,menu)
  1155.                 (setq menu-center ,center)
  1156.                 (setq saved-bit-map (save-bit-map ,menu))
  1157.                 ,@body)
  1158.          (restore-bit-map ,menu :kill t)))))
  1159.  
  1160. (defmethod marking-menu-track ((menu marking-menu) where)
  1161.   (let* ((sv (find-marking-menu menu where))
  1162.          (menu-actzone (slot-value menu 'menu-actzone))
  1163.          (target-menu menu))
  1164.     (when (and (mouse-down-p)
  1165.                (eq menu sv)
  1166.                (or (null menu-actzone)
  1167.                    (not (zone-pointerp menu-actzone))
  1168.                    (point-in-rect-p menu-actzone where)))
  1169.       (with-focused-view menu
  1170.         (if  (double-click-p)
  1171.           (menu-double-click-action menu)
  1172.           (let ((menu-items (menu-items menu)))
  1173.             (when menu-items
  1174.               (let* (stroke 
  1175.                      cond 
  1176.                      prev-item point
  1177.                      (start-pos (local-to-global menu where)))
  1178.                 (with-saved-bit-map (menu :center start-pos)
  1179.                   (multiple-value-setq (stroke cond point)
  1180.                     (mark-stroke menu start-pos))
  1181.                   (erase-stroke stroke)
  1182.                   (setq prev-item (selected-slice menu :position point))
  1183.                   (when (equal cond 'still)
  1184.                     (multiple-value-setq (prev-item target-menu)
  1185.                           (track-and-hilite menu prev-item))
  1186.                     (setq prev-item nil)))
  1187.                 (with-port (wptr menu)
  1188.                   (when (and prev-item (eq menu target-menu))
  1189.                     (let ((menu-item (nth prev-item (menu-items menu))))
  1190.                       (do-menu-item-action menu-item menu-item))))
  1191.                 t))))))))
  1192.  
  1193. (defun draw-radial-line (center point &optional flag)
  1194.   ;; draws a line from the center to the given point
  1195.   (#_MoveTo :long center)
  1196.   (#_LineTo :long center)
  1197.   (#_LineTo :long point)
  1198.   (when flag
  1199.     (format t "~&~s ~a -> ~a~%"
  1200.             flag (point-string center) (point-string point))))
  1201.  
  1202. (defun get-centers (menu)
  1203.   (when menu
  1204.     (setq menu (slot-value menu 'ccl::owner))
  1205.     (let (centers)
  1206.       (loop
  1207.         while menu
  1208.         finally (return-from get-centers centers)
  1209.         do (push (list (slot-value menu 'menu-center)
  1210.                        (slot-value menu 'menu-hole)
  1211.                        menu) centers)
  1212.         (setq menu (menu-owner menu))))))
  1213.  
  1214. (defun point-in-hole (menu-center menu-hole point)
  1215.   ;; determines whether the point is in the center of the menu
  1216.     (let* ((diff (subtract-points point menu-center)))
  1217.       (< (+ (abs (point-h diff)) (abs (point-v diff))) menu-hole)))
  1218.  
  1219. (defun find-hole (centers point)
  1220.   (dolist (menu centers)
  1221.     (when (point-in-hole (first menu) (second menu) point)
  1222.       (return-from find-hole (third menu)))))
  1223.  
  1224. (defun is-menu (menu-item)
  1225.   (and menu-item
  1226.        (slot-exists-p menu-item 'ccl::menu-id)))
  1227.  
  1228. (defun erase-to-parent (menu)
  1229.   (let ((prev-menu (menu-owner menu)) prev-center)
  1230.     (with-slots (menu-center) menu
  1231.       (when prev-menu
  1232.         (setq prev-center (slot-value prev-menu 'menu-center))
  1233.         (draw-radial-line prev-center menu-center)
  1234.         (restore-bit-map menu)))))
  1235.  
  1236. (defun outside-circle (center radius point)
  1237.   ;; determines whether the point is outside the circle of the specified radius
  1238.   (let* ((diff (subtract-points center point)))
  1239.     (> (+ (abs (point-h diff)) (abs (point-v diff))) radius)))
  1240.  
  1241. (defmacro push-viewer (submenu view viewer)
  1242.   ;; ensure that the submenu inherits the attributes of the root menu
  1243.   `(progn
  1244.      (dolist (el '(menu-opaque menu-floating hide on-axis turn in-position))
  1245.        (when (slot-exists-p ,submenu el)
  1246.          (setf (slot-value ,submenu el)
  1247.                (slot-value ,view el))))
  1248.      (when (slot-value ,view 'turn)
  1249.        (setf (slot-value ,submenu 'on-axis)
  1250.              (not (slot-value ,view 'on-axis))))
  1251.      (setq ,viewer ,view)))
  1252.  
  1253. (defmacro pop-viewer (viewer submenu)
  1254.   `(with-slots (saved-bit-map) ,submenu
  1255.      (setq ,viewer nil)
  1256.      (safe-kill-picture saved-bit-map)))
  1257.  
  1258. (defmacro with-pushed-viewer ((submenu view viewer) &rest body)
  1259.   `(progn
  1260.      (push-viewer ,submenu ,view ,viewer)
  1261.      ,@body
  1262.      (pop-viewer ,viewer ,submenu)))
  1263.  
  1264. (defun is-marking-menu (menu)
  1265.   (and (is-menu menu) (menu-items menu)))
  1266.  
  1267. (defmethod track-and-hilite ((menu marking-menu) prev-item)
  1268.   ;; Hilites the various sections of the menu and tracks mouse movement
  1269.   ;; until the mouse botton is released.
  1270.   (with-slots (menu-center viewer pop-width) menu
  1271.     (let (last-point 
  1272.           point
  1273.           item
  1274.           is-menu
  1275.           menu-item
  1276.           menu-item-center
  1277.           (view (if viewer viewer menu))
  1278.           target-menu
  1279.           mouse-still
  1280.           (centers (get-centers menu))
  1281.           parent-center)
  1282.       ;; bug: need to mention under MCL2.0f3
  1283.       menu-item-center parent-center
  1284.       (display-marking-menu menu)
  1285.       (when prev-item 
  1286.         (invert-item menu prev-item))
  1287.       (setq menu-item (when prev-item (nth prev-item (menu-items menu)))
  1288.             is-menu (is-marking-menu menu-item))
  1289.       (with-pen-state (:pnMode #$patxor)
  1290.         (loop
  1291.           (setq target-menu menu)
  1292.           (unless (#_WaitMouseUp)
  1293.             (when last-point
  1294.               (draw-radial-line menu-center last-point)
  1295.               (when prev-item
  1296.                 (invert-item menu prev-item)))
  1297.             (return t))
  1298.           
  1299.           (setq point (mouse-position menu)
  1300.                 item (selected-slice menu :position point))
  1301.           
  1302.           (unless (equal last-point point)
  1303.             (when last-point
  1304.               (draw-radial-line menu-center last-point))
  1305.             (setq last-point point)
  1306.             (draw-radial-line menu-center last-point)
  1307.             (unless (equal item prev-item)
  1308.               (invert-item menu prev-item)
  1309.               (invert-item menu item)
  1310.               (setq prev-item item)
  1311.               (when prev-item
  1312.                 (setq menu-item (nth prev-item (menu-items menu))
  1313.                       is-menu (is-marking-menu menu-item)))))
  1314.           
  1315.           (setq mouse-still (mouse-still view))
  1316.           (when mouse-still
  1317.             (if (setq target-menu (find-hole centers point))
  1318.               (unless (eq target-menu menu)
  1319.                 (draw-radial-line menu-center last-point)
  1320.                 (return))
  1321.               (when (and is-menu
  1322.                          (outside-circle menu-center pop-width point))
  1323.                 (setq menu-item (nth prev-item (menu-items menu)))
  1324.                 (check-menu-box menu)
  1325.                 (setq parent-center menu-center)
  1326.                 (with-slots (viewer hide) menu-item
  1327.                   (with-pushed-viewer (menu-item view viewer)
  1328.                     (if hide
  1329.                       (show-slice menu prev-item last-point)   ; display the new menu and draw line
  1330.                       (draw-radial-line menu-center last-point)) ; draw the line
  1331.                     (multiple-value-setq (target-menu point)
  1332.                       (hier-menu-track menu-item last-point menu-center))
  1333.                     (setq menu-item-center (slot-value menu-item 'menu-center))))
  1334.                 (setq prev-item nil)
  1335.                   (unless (eq target-menu menu)
  1336.                     (return))
  1337.                 (setq last-point nil)
  1338.                 (restore-bit-map menu)
  1339.                 (display-marking-menu menu)))))
  1340.         (erase-to-parent menu))
  1341.       (when (eq target-menu menu)
  1342.         (when prev-item
  1343.           (let ((menu-item (nth prev-item (menu-items menu))))
  1344.             (do-menu-item-action menu-item menu-item)))
  1345.         (setq target-menu nil))
  1346.       (values prev-item
  1347.               target-menu
  1348.               point))))
  1349.  
  1350. (defun show-slice (menu item last-point)
  1351.   (if (slot-value menu 'menu-floating)
  1352.     (do-parent menu item last-point)
  1353.     (with-slots (menu-rect menu-center menu-height on-axis menu-opaque) menu
  1354.       (let* ((size (length (menu-items menu)))
  1355.              (slice-size (/ full-circle size))
  1356.              (start-angle (* item slice-size))
  1357.              bottom-right)
  1358.         (unless on-axis (decf start-angle (/ slice-size 2)))
  1359.         (when (minusp start-angle)
  1360.           (decf start-angle 360))
  1361.         (rlet ((r :rect))
  1362.           (draw-radial-line menu-center last-point)
  1363.           (restore-bit-map menu)
  1364.           (copy-record menu-rect :rect r)
  1365.           (#_offsetRect :ptr r :long menu-center)
  1366.           (setq bottom-right (rref r :rect.bottomRight))
  1367.           (rset r :rect.bottomRight (subtract-points bottom-right
  1368.                                                      (point-box menu-height)))
  1369.           (if menu-opaque
  1370.             (with-pen-state (:pnMode #$patBic
  1371.                                      :pnPat *light-gray-pattern*)
  1372.               (#_PaintArc :ptr r :signed-integer start-angle :signed-integer slice-size))
  1373.             (#_eraseArc :ptr r :signed-integer start-angle :signed-integer slice-size))
  1374.           (#_FrameArc :ptr r :signed-integer start-angle :signed-integer slice-size)
  1375.           (write-title menu item)
  1376.           (draw-hole menu r))))))
  1377.  
  1378. (defun write-title (menu n)
  1379.   (with-slots (menu-title-rect menu-floating menu-center) menu
  1380.     (let* ((menu-item (nth n (menu-items menu)))
  1381.            (item-spec (nth n  menu-title-rect))
  1382.            circle-pos)
  1383.       (draw-title menu menu-item item-spec nil t)
  1384.       (unless menu-floating
  1385.         (setq circle-pos (nth (1+ n) menu-title-rect))
  1386.         (unless circle-pos (setq circle-pos (nth 0 menu-title-rect)))
  1387.         (setq circle-pos (item-slice-point circle-pos))
  1388.         (when circle-pos
  1389.         (#_MoveTo :long menu-center)
  1390.         (#_LineTo :long circle-pos))))))
  1391.  
  1392. (defun do-parent (menu n point)
  1393.   (with-pen-state (:pnMode #$patxor :pnPat *black-pattern*)
  1394.     (with-slots (menu-center) menu
  1395.       (rlet ((r :rect))
  1396.         (draw-radial-line menu-center point)
  1397.         (restore-bit-map menu :kill nil)
  1398.         (write-title menu n)
  1399.         (draw-hole menu r)))))
  1400.  
  1401. (defmethod hier-menu-track ((menu marking-menu) where target-menu-center)
  1402.   (when (mouse-down-p)
  1403.     (let ((menu-items (menu-items menu)))
  1404.       (when menu-items
  1405.         (let (prev-item 
  1406.               (start-pos where)
  1407.               (point where)
  1408.               (target-menu menu))
  1409.           (with-saved-bit-map (menu :center start-pos)
  1410.             (draw-radial-line start-pos target-menu-center)
  1411.             (setq prev-item (selected-slice menu :position point))
  1412.             (loop
  1413.               do (multiple-value-setq (prev-item target-menu point)
  1414.                    (track-and-hilite menu prev-item))
  1415.               while (eq target-menu menu)
  1416.               finally (progn (when target-menu
  1417.                                (setq prev-item nil))
  1418.                              (return))
  1419.               do (progn (restore-bit-map menu :kill nil)
  1420.                         (display-marking-menu menu)))
  1421.             )
  1422.           (values target-menu point))))))
  1423.  
  1424. (defmethod mouse-still ((menu marking-menu))
  1425.   ;; determines whether the mouse is relatively still -
  1426.   ;; the mouse button is down and the manhattan distance of
  1427.   ;; the current position of the mouse is at most menu-start-tol pixels
  1428.   ;; from the mouse-position when the method is run.
  1429.   (with-slots (menu-start-tol pop-up-time) menu
  1430.     (let ((start (mouse-position menu))
  1431.           (t0 (get-internal-run-time))
  1432.           loc
  1433.           still)
  1434.       (loop
  1435.         until (or
  1436.                (and (> (- (get-internal-run-time) t0) pop-up-time)
  1437.                     (setq still t))
  1438.               (not (#_WaitMouseUp)))
  1439.         do (setq loc (subtract-points (mouse-position menu)
  1440.                                    start))
  1441.         until (> (+ (abs (point-h loc)) (abs (point-v loc)))
  1442.                  menu-start-tol)
  1443.         finally (return still)))))
  1444.  
  1445. (defmethod save-bit-map ((menu marking-menu))
  1446.   ;; saves the bit map of the graph-port corresponding to the offset menu-rect
  1447.   ;; of the window containing the marking-menu
  1448.   (check-menu-box menu t)
  1449.   (with-slots (menu-rect menu-center saved-bit-map menu-floating real-corners) menu
  1450.     (rlet ((rect :rect))
  1451.       (safe-kill-picture saved-bit-map)
  1452.       (if menu-floating
  1453.         (progn (rset rect :rect.topLeft (first real-corners))
  1454.                (rset rect :rect.bottomRight (second real-corners)))
  1455.         (copy-record menu-rect :rect rect))
  1456.       (#_offsetRect :ptr rect :long menu-center)
  1457.       (setq saved-bit-map (save-screen-map (containing-view menu) rect)))))
  1458.  
  1459. (defmethod restore-bit-map ((menu marking-menu) &key kill)
  1460.   ;; restores the bit map corresponding to the offset menu-rect
  1461.   (with-slots (menu-center menu-rect saved-bit-map menu-floating real-corners) menu
  1462.     (rlet ((rect :rect))
  1463.       (copy-record menu-rect :rect rect)
  1464.       (if menu-floating
  1465.         (progn (rset rect :rect.topLeft (first real-corners))
  1466.                (rset rect :rect.bottomRight (second real-corners)))
  1467.         (copy-record menu-rect :rect rect))
  1468.       (#_offsetRect :ptr rect :long menu-center)
  1469.       (restore-screen-map saved-bit-map rect)
  1470.       (when kill
  1471.         (safe-kill-picture saved-bit-map)))))
  1472.  
  1473. (defun check-arrow ()
  1474.   (def-load-pointers init-arrow nil (get-arrow))
  1475.   (setq *save-exit-functions* 
  1476.         (remove-if 
  1477.          #'(lambda (item)
  1478.              (equal (function-name item) 'delete-arrow))
  1479.          *save-exit-functions*))
  1480.   (push  #'delete-arrow *save-exit-functions*)
  1481.   t)
  1482.  
  1483. (check-arrow)
  1484. #|
  1485.    For complete examples see:
  1486.      marking-menu-demo.lisp
  1487.      hier-menu-demo.lisp
  1488. |#
  1489.